Cream of the Crop 26/Cream of the Crop 26.iso/program/qbasix.zip/QBASIX.PRO

Text File | 1994-05-08 | 14.5 KB | 520 lines

'******************************************************************************
'*            QBASIX - assembler routines for QBASIC - version 2              *
'*                         The QBASIX procedures                              *
'*                      (c) Hans Lunsing - 04/1994                            *
'******************************************************************************

'This file holds the QBASIX procedures together with their types and
'constants. You can insert them in your own programs as needed. Don't
'forget to copy the routines called by them and the declarations going
'with them also.
'If you use procedures calling the QBASIX library QBASIX.EXE you have
'to build your program inside the shell required for using the library.
'This shell checks the existence of QBASIX and passes its position in
'memory to the program. You will find it in the file QBASIX.BAS. You can
'simply add your own program code with its declarations and procedures
'to it at the indicated positions.

DEFINT A-Z

' Type for storing video information

TYPE VideoType
  'Is necessary for use of SUB GetVideoInfo
  Mode    AS INTEGER                    'video mode
  Rows    AS INTEGER                    'number of rows
  Cols    AS INTEGER                    'number of columns
  Page    AS INTEGER                    'active screen page
  Offs    AS INTEGER                    'offset of the same in video memory
  Segment AS INTEGER                    'segment of the same
  CRT     AS INTEGER                    'adapter: MDA = 1, CGA = 2, EGA = 3,
                    'MCGA = 4, VGA = 5, HERC = 11,
                    'OTHER = 0
  Colour  AS INTEGER                    '-1 if color screen,
                    '0 if monochrome screen
  Port    AS INTEGER                    'port number of video controller
END TYPE

' Registertype to use with INTERRUPTX and MSDOS

TYPE RegTypeX
  AX AS INTEGER
  BX AS INTEGER
  CX AS INTEGER
  DX AS INTEGER
  bp AS INTEGER
  si AS INTEGER
  di AS INTEGER
  flags AS INTEGER
  ds AS INTEGER
  ES AS INTEGER
END TYPE

' Numbers of the assembler routines:

CONST cBlinkStatus = 0
CONST cFillWindow = 1
CONST cGetActiveColor = 2
CONST cGetVideoInfo = 3
CONST cMsDOS = 4
CONST cInterruptX = 5
CONST cLptReady = 6
CONST cMemCopy = 7
CONST cMemScan = 8
CONST cSaveWindow = 9
CONST cRestoreWindow = 10
CONST cSetError = 11
CONST cShift = 12
CONST cToggleBlinkBit = 13
CONST cCmd = 14
CONST cSetCmd = 15

' Logical constants:

CONST TRUE = -1, FALSE = 0

' Numbers of the discerned video cards
' Useful with SUB GetVideoInfo

CONST OTHER = 0, MDA = 1, CGA = 2, EGA = 3, MCGA = 4, VGA = 5, HERC = 11

' Directions
' Useful with SUB Shift

CONST LEFT = 0, RIGHT = 1

' Effect of blink bit of screen color code
' Useful with FUNCTION BlinkStatus and SUB ToggleBlinkBit

CONST BRIGHT = 0, BLINKING = -1

' Declarations of subroutines and functions

DECLARE FUNCTION BlinkStatus ()
DECLARE FUNCTION Cmd$ ()
DECLARE FUNCTION Exch (Integ)
DECLARE FUNCTION GetActiveColor ()
DECLARE FUNCTION GetVideoMode ()
DECLARE FUNCTION Hi (i)
DECLARE FUNCTION IntMax (Int1, Int2)
DECLARE FUNCTION IntMin (Int1, Int2)
DECLARE FUNCTION Lo (i)
DECLARE FUNCTION LptReady (Lpt, Status)
DECLARE FUNCTION MemScan& (Bytes&, SourceSeg, SourceOffs, Search$)
DECLARE FUNCTION PeekString$ (Segment, Offset, Length)
DECLARE FUNCTION PeekWord (Segment, OffSet)
DECLARE FUNCTION SetWord (HiByte, LoByte)
DECLARE SUB Attr (Fore, Back)
DECLARE SUB FillWindow (Top, Left, Bottom, Right, Ascii, Fore, Back)
DECLARE SUB GetAttr (Fore, Back)
DECLARE SUB GetCursorLoc (Row, Column)
DECLARE SUB GetVideoInfo (Video AS VideoType)
DECLARE SUB InterruptX (IntNo, InReg AS RegTypeX, OutReg AS RegTypeX)
DECLARE SUB MSDOS (InReg AS RegTypeX, OutReg AS RegTypeX)
DECLARE SUB MemCopy (Bytes&, FromSeg, FromOffs, ToSeg, ToOffs)
DECLARE SUB PokeWord (Segment, OffSet, Value)
DECLARE SUB RestoreScreen (Buffer())
DECLARE SUB SavePartScreen (Top, Left, Bottom, Right, Buffer())
DECLARE SUB SaveScreen (Buffer())
DECLARE SUB SetCmd (CmdStr$)
DECLARE SUB SetCursorLoc (Row, Column)
DECLARE SUB SetError (ErrorLevel)
DECLARE SUB SetHi (i, HiByte)
DECLARE SUB SetLo (i, LoByte)
DECLARE SUB Shift (Direction, SomeInt, Bits)
DECLARE SUB ToggleBlinkBit (Toggle)

SUB Attr (Fore, Back)
  'Replacement for COLOR, especially handy when using bright background
  'colors.
  'Does NOT use QBASIX.EXE.

  SHARED SFore, SBack, AttrBefore
  IF NOT AttrBefore THEN
    SFore = 7
    AttrBefore = TRUE
  END IF
  IF Fore >= 0 THEN SFore = Fore
  IF Back >= 0 THEN SBack = Back
  IF SBack AND 8 THEN
    f = SFore OR 16
    b = SBack XOR 8
  ELSE
    f = SFore
    b = SBack
  END IF
  COLOR f, b
END SUB

FUNCTION BlinkStatus
  'Returns -1 if blinking text is enabled or 0 if it is not.
  'Does use QBASIX.EXE.
  'For indicating the effect of the blink bit it is handy to use the
  'constants BRIGHT and BLINKING defined above, for instance
  'IF BlinkStatus = BRIGHT THEN ....

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Status, cBlinkStatus, OffsBasix)
  BlinkStatus = Status
END FUNCTION

FUNCTION Cmd$
  'Passes a command line, set by means of the switch /cmd (as with QB)
  'when calling QBASIC, to the program.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  Temp$ = SPACE$(80)
  DEF SEG = SegBasix
  CALL ABSOLUTE(Temp$, cCmd, OffsBasix)
  Cmd$ = RTRIM$(Temp$)
END FUNCTION

FUNCTION Exch (Integ)
  'Exchanges high and low byte of integer.
  'Does NOT use QBASIX.EXE.

  Ptr1 = VARPTR(Integ)
  Ptr2 = VARPTR(Exchange)
  DEF SEG
  POKE Ptr2, PEEK(Ptr1 + 1)
  POKE Ptr2 + 1, PEEK(Ptr1)
  Exch2 = Exchange
END FUNCTION

SUB FillWindow (Top, Left, Bottom, Right, Ascii, Fore, Back)
  'Colors foreground and/or background of a rectangular text screen
  'area and/or fills it with a character.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Top, Left, Bottom, Right, Ascii, Fore, Back, cFillWindow, OffsBasix)
END SUB

FUNCTION GetActiveColor
  'Returns the screen color active in DOS.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(ActiveColor, cGetActiveColor, OffsBasix)
  GetActiveColor = ActiveColor
END FUNCTION

SUB GetAttr (Fore, Back)
  'Returns the colors set with the previous call of Attr.
  'Meaningful only when using SUB Attr.
  'Does NOT use QBASIX.EXE.

  SHARED SFore, SBack, AttrBefore
  IF NOT AttrBefore THEN
    SFore = 7
    AttrBefore = TRUE
  END IF
  Fore = SFore
  Back = SBack
END SUB

SUB GetCursorLoc (Row, Column)
  'Gets the location of the cursor by way of the BIOS.
  'Does use SUB InterruptX and QBASIX.EXE.

  DIM Reg AS RegTypeX
  Reg.AX = &H300
  Reg.BX = 0
  InterruptX &H10, Reg, Reg
  Row = Reg.DX \ 256 + 1                'from 0 to 1 as a base
  Column = Reg.DX MOD 256 + 1
END SUB

SUB GetVideoInfo (Video AS VideoType)
  'Returns information about the video configuration.
  'Does use TYPE VideoType and QBASIX.EXE.
  'It is handy to test for the type of video card with the help of the
  'constants VGA, EGA etc., defined above.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Video, cGetVideoInfo, OffsBasix)
END SUB

FUNCTION GetVideoMode
  'Returns the active video mode.
  'Does use SUB InterruptX and QBASIX.EXE.

  DIM Reg AS RegTypeX
  Reg.AX = &HF00
  InterruptX &H10, Reg, Reg
  GetVideoMode = (Reg.AX AND &HFF)
END FUNCTION

FUNCTION Hi(Integ)
  'Returns high byte of integer.
  'Does NOT use QBASIX.EXE.

  DEF SEG
  Hi = PEEK(VARPTR(Integ) + 1)
END FUNCTION

SUB InterruptX (IntNo, InReg AS RegTypeX, OutReg AS RegTypeX)
  'Executes interrupt.
  'Does use TYPE RegTypeX and QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(IntNo, InReg, OutReg, cInterruptX, OffsBasix)
END SUB

FUNCTION IntMax(Int1, Int2)
  'Returns the maximum of 2 integers
  'Does NOT use QBASIX.EXE.

  IF Int1 >= Int2 THEN
    IntMax = Int1
  ELSE
    IntMax = Int2
  END IF
END FUNCTION

FUNCTION IntMin(Int1, Int2)
  'Returns the minimum of 2 integers
  'Does NOT use QBASIX.EXE.

  IF Int1 <= Int2 THEN
    IntMin = Int1
  ELSE
    IntMin = Int2
  END IF
END FUNCTION

FUNCTION Lo(Integ)
  'Returns low byte of integer.
  'Does NOT use QBASIX.EXE.

  Lo = Integ AND 255
END FUNCTION

FUNCTION LptReady (Lpt, Status)
  'Determines if printer is ready and passes printer status.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Lpt, Status, Ready, cLptReady, OffsBasix)
  LptReady = Ready
END FUNCTION

SUB MemCopy (Bytes&, FromSeg, FromOffs, ToSeg, ToOffs)
  'Copies a number of bytes from one memory location to another.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Bytes&, FromSeg, FromOffs, ToSeg, ToOffs, cMemCopy, OffsBasix)
END SUB

FUNCTION MemScan& (Bytes&, SourceSeg, SourceOffs, Search$)
  'Scans a memory block of at most 64Kb for a string.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Bytes&, SourceSeg, SourceOffs, Search$, Where&, cMemScan, OffsBasix)
  MemScan& = Where&
END FUNCTION

SUB MSDOS (InReg AS RegTypeX, OutReg AS RegTypeX)
  'Executes DOS interrupt.
  'Does use TYPE RegTypeX and QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(InReg, OutReg, cMsDOS, OffsBasix)
END SUB

FUNCTION PeekString$ (Segment, Offset, Length)
  'Reads a string of specified length from specified address.
  'Does NOT use QBASIX.EXE.

  IF Length > 0 THEN
    PeekString$ = SPACE$(Length)
    DEF SEG = Segment
    FOR i = 1 TO Length
      MID$(PeekString$, i, 1) = CHR$(PEEK(Offset - 1 + i))
    NEXT i
  ELSE
    PeekString$ = ""
  END IF
END FUNCTION

FUNCTION PeekWord (Segment, Offset)
  'Reads a word from the specified address.
  'Does NOT use QBASIX.EXE.

  DEF SEG = Segment
  Word = PEEK(Offset)
  HiByte = PEEK(Offset + 1)
  DEF SEG
  POKE VARPTR(Word) + 1, HiByte
  PeekWord = Word
END FUNCTION

SUB PokeWord (Segment, Offset, Word)
  'Writes a word to the specified address.
  'Does NOT use QBASIX.EXE.

  DEF SEG
  HiByte = PEEK(VARPTR(Word) + 1)
  DEF SEG = Segment
  POKE Offset, Word
  POKE Offset + 1, HiByte
END SUB

SUB RestoreScreen (Buffer())
  'Restores rectangular text screen area (window) from buffer array.
  'Meaningful only when using SUB SaveScreen or SUB SavePartScreen.
  'Does use SUB Attr and QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  i = LBOUND(Buffer)
  IF UBOUND(Buffer) - i < 8 THEN EXIT SUB
  DEF SEG = SegBasix
  CALL ABSOLUTE(Buffer(i + 4), Buffer(i + 5), Buffer(i + 6), Buffer(i + 7), SEG Buffer(i + 8), cRestoreWindow, OffsBasix)
  DEF SEG
  LOCATE Buffer(i), Buffer(i + 1)
  Attr Buffer(i + 2), Buffer(i + 3)
END SUB

SUB SavePartScreen (Top, Left, Bottom, Right, Buffer())
  'Saves screen window with cursor location and color setting in buffer
  'array. Meaningful only when using SUB RestoreScreen.
  'Does use SUB GetAttr and QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  'N.B.: valid coordinates are not checked upon.
  i = LBOUND(Buffer)
  j = i + 7 + (Bottom - Top + 1) * (Right - Left + 1)
  IF UBOUND(Buffer) < j THEN
    REDIM Buffer(i TO j)
  END IF
  Buffer(i) = CSRLIN
  Buffer(i + 1) = POS(0)
  GetAttr Buffer(i + 2), Buffer(i + 3)
  Buffer(i + 4) = Top
  Buffer(i + 5) = Left
  Buffer(i + 6) = Bottom
  Buffer(i + 7) = Right
  DEF SEG = SegBasix
  CALL ABSOLUTE(Top, Left, Bottom, Right, SEG Buffer(i + 8), cSaveWindow, OffsBasix)
END SUB

SUB SaveScreen (Buffer())
  'Saves full screen with cursor location and color setting in buffer
  'array, taking into account the active video mode.
  'Meaningful only when using SUB RestoreScreen.
  'Does use SUB GetAttr, SUB GetVideoInfo and QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DIM Video AS VideoType
  GetVideoInfo Video
  i = LBOUND(Buffer)
  j = i + 7 + Video.Rows * Video.Cols
  IF UBOUND(Buffer) < j THEN
    REDIM Buffer(i TO j)
  END IF
  Buffer(i) = CSRLIN
  Buffer(i + 1) = POS(0)
  GetAttr Buffer(i + 2), Buffer(i + 3)
  Buffer(i + 4) = 1
  Buffer(i + 5) = 1
  Buffer(i + 6) = Video.Rows
  Buffer(i + 7) = Video.Cols
  DEF SEG = SegBasix
  CALL ABSOLUTE(1, 1, Video.Rows, Video.Cols, SEG Buffer(i + 8), cSaveWindow, OffsBasix)
END SUB

SUB SetCmd (CmdStr$)
  'Changes the command line meant for the basic program from inside QBASIC.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  IF IsQBASIX THEN
    DEF SEG = SegBasix
    CALL ABSOLUTE(CmdStr$, cSetCmd, OffsBasix)
  ELSE
    PRINT "Geen opdrachtregel beschikbaar omdat QBASIX niet is geladen."
  END IF
END SUB

SUB SetCursorLoc (Row, Column)
  'Sets cursor location by way of the BIOS
  'Does use SUB InterruptX and QBASIX.EXE.

  DIM Reg AS RegTypeX
  Reg.AX = &H200
  Reg.BX = 0
  Reg.DX = (Row - 1) * 256 + (Column - 1) 'from 1 to 0 as a base
  InterruptX &H10, Reg, Reg
END SUB

SUB SetError (ErrorLevel)
  'Sets termination code (error level) of the program.
  'Does use QBASIX.EXE.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(ErrorLevel, cSetError, OffsBasix)
END SUB

SUB SetHi (i, HiByte)
  'Gives high byte of integer another value.
  'Does NOT use QBASIX.EXE.

  DEF SEG
  POKE VARPTR(i) + 1, HiByte
END SUB

SUB SetLo (i, LoByte)
  'Gives low byte of integer another value.
  'Does NOT use QBASIX.EXE.

  DEF SEG
  POKE VARPTR(i), LoByte
END SUB

FUNCTION SetWord (HiByte, LoByte)
  'Forms integer from high byte and low byte.
  'Does NOT use QBASIX.EXE.

  DEF SEG
  POKE VARPTR(i) + 1, HiByte
  POKE VARPTR(i), LoByte
  SetWord = i
END FUNCTION

SUB Shift (Direction, SomeInt, Bits)
  'Shifts bits of integer a number of places to the left or the right.
  'Does use QBASIX.EXE.
  'For indicating the direction in which the bits are to be shifted it
  'is convenient to use the constants LEFT and RIGHT defined above.

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Direction, SomeInt, Bits, cShift, OffsBasix)
END SUB

SUB ToggleBlinkBit (Toggle)
  'Sets the effect of the blink bit of the screen color code to blinking
  'text or bright background.
  'Does use QBASIX.EXE.
  'For indicating the effect of the blink bit it is handy to use the
  'constants BRIGHT and BLINKING defined above, for instance
  'CALL ToggleBlinkbit (BRIGHT)

  SHARED SegBasix, OffsBasix
  DEF SEG = SegBasix
  CALL ABSOLUTE(Toggle, cToggleBlinkBit, OffsBasix)
END SUB